home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / unix / volume10 / comobj.lisp / part04 < prev    next >
Encoding:
Internet Message Format  |  1987-07-30  |  61.6 KB
  1. Path: uunet!rs
  2. From: rs@uunet.UU.NET (Rich Salz)
  3. Newsgroups: comp.sources.unix
  4. Subject: v10i078:  Common Objects, Common Loops, Common Lisp, Part04/13
  5. Message-ID: <745@uunet.UU.NET>
  6. Date: 31 Jul 87 20:00:06 GMT
  7. Organization: UUNET Communications Services, Arlington, VA
  8. Lines: 1664
  9. Approved: rs@uunet.UU.NET
  10.  
  11. Submitted-by: Roy D'Souza <dsouza%hplabsc@hplabs.HP.COM>
  12. Posting-number: Volume 10, Issue 78
  13. Archive-name: comobj.lisp/Part04
  14.  
  15. #! /bin/sh
  16. # This is a shell archive.  Remove anything before this line, then unpack
  17. # it by saving it into a file and typing "sh file".  To overwrite existing
  18. # files, type "sh file -c".  You can also feed this as standard input via
  19. # unshar, or by typing "sh <file", e.g..  If this archive is complete, you
  20. # will see the following message at the end:
  21. #        "End of archive 4 (of 13)."
  22. # Contents:  class-slots.l defclass.l fsc-low.l regress.l
  23. PATH=/bin:/usr/bin:/usr/ucb ; export PATH
  24. if test -f 'class-slots.l' -a "${1}" != "-c" ; then 
  25.   echo shar: Will not clobber existing file \"'class-slots.l'\"
  26. else
  27. echo shar: Extracting \"'class-slots.l'\" \(14319 characters\)
  28. sed "s/^X//" >'class-slots.l' <<'END_OF_FILE'
  29. X;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  30. X;;;
  31. X;;; *************************************************************************
  32. X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  33. X;;;
  34. X;;; Use and copying of this software and preparation of derivative works
  35. X;;; based upon this software are permitted.  Any distribution of this
  36. X;;; software or derivative works must comply with all applicable United
  37. X;;; States export control laws.
  38. X;;; 
  39. X;;; This software is made available AS IS, and Xerox Corporation makes no
  40. X;;; warranty about the software, its performance or its conformity to any
  41. X;;; specification.
  42. X;;; 
  43. X;;; Any person obtaining a copy of this software is requested to send their
  44. X;;; name and post office or electronic mail address to:
  45. X;;;   CommonLoops Coordinator
  46. X;;;   Xerox Artifical Intelligence Systems
  47. X;;;   2400 Hanover St.
  48. X;;;   Palo Alto, CA 94303
  49. X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  50. X;;;
  51. X;;; Suggestions, comments and requests for improvements are also welcome.
  52. X;;; *************************************************************************
  53. X;;;
  54. X
  55. X(in-package 'pcl)
  56. X
  57. X  ;;   
  58. X;;;;;; Slot access for the class class.
  59. X  ;;   get-slot-using-class and friends
  60. X;;; At last the meta-braid is up.  The method class-instance-slots exists and there
  61. X;;; is peace in the land.  Now we can finish get-slot, put-slot and friends.
  62. X
  63. X(defmacro get-slot-using-class--class (class object slot-name
  64. X                                       dont-call-slot-missing-p default)
  65. X  (once-only (slot-name)
  66. X    `(let* ((.wrapper.
  67. X          (iwmc-class-class-wrapper ,object))
  68. X            (.get-slot-offset.
  69. X          (class-wrapper-get-slot-offset .wrapper. ,slot-name)))
  70. X       (if (eq (class-wrapper-cached-key .wrapper. .get-slot-offset.)
  71. X           ,slot-name)
  72. X           (get-static-slot--class
  73. X             ,object (class-wrapper-cached-val .wrapper. .get-slot-offset.))
  74. X           (get-slot-using-class--class-internal
  75. X             ,class ,object ,slot-name ,dont-call-slot-missing-p ,default)))))
  76. X
  77. X
  78. X(defmacro put-slot-using-class--class (class object slot-name new-value
  79. X                                       dont-call-slot-missing-p)
  80. X  (once-only (slot-name)
  81. X    `(let* ((.wrapper. (iwmc-class-class-wrapper ,object))
  82. X            (.get-slot-offset. (class-wrapper-get-slot-offset .wrapper. ,slot-name)))
  83. X       (if (eq (class-wrapper-cached-key .wrapper. .get-slot-offset.) ,slot-name)
  84. X           (setf (get-static-slot--class
  85. X                   ,object (class-wrapper-cached-val .wrapper. .get-slot-offset.))
  86. X                 ,new-value)
  87. X            (put-slot-using-class--class-internal
  88. X              ,class ,object ,slot-name ,new-value ,dont-call-slot-missing-p)))))
  89. X
  90. X(defmacro get-slot--class (object slot-name)
  91. X  (once-only (object)
  92. X    `(get-slot-using-class--class
  93. X       (class-of--class ,object) ,object ,slot-name () ())))
  94. X
  95. X(defmacro put-slot--class (object slot-name new-value)
  96. X  (once-only (object)
  97. X    `(put-slot-using-class--class
  98. X       (class-of--class ,object) ,object ,slot-name ,new-value ())))
  99. X
  100. X(defmeth get-slot-using-class ((class basic-class) object slot-name
  101. X                   &optional dont-call-slot-missing-p default)
  102. X  (get-slot-using-class--class
  103. X    class object slot-name dont-call-slot-missing-p default))
  104. X
  105. X(defmeth put-slot-using-class ((class basic-class) object slot-name new-value
  106. X                   &optional dont-call-slot-missing-p)
  107. X  (put-slot-using-class--class
  108. X    class object slot-name new-value dont-call-slot-missing-p))
  109. X
  110. X(defmeth remove-dynamic-slot-using-class ((class basic-class)
  111. X                      object slot-name)
  112. X  (ignore class)
  113. X  (remove-dynamic-slot--class object slot-name))
  114. X
  115. X;;;
  116. X;;; with-slot-internal--class is macro which makes code which accesses the
  117. X;;; slots of instances with meta-class class more readable.  The macro itself
  118. X;;; is kind of dense though.  In the following call:
  119. X;;;   (WITH-SLOT-INTERNAL--CLASS (CLASS OBJECT SLOT-NAME T)
  120. X;;;     (:INSTANCE (INDEX) . instance-case-code)
  121. X;;;     (:DYNAMIC (LOC NEWP) . dynamic-case-code)
  122. X;;;     (:CLASS (SLOTD) . class-case-code)
  123. X;;;     (NIL () . nil-case-code))
  124. X;;; If the slot is found and has allocation:
  125. X;;;   :instance   instance-case-code is evaluated with INDEX bound to the
  126. X;;;               index of the slot.
  127. X;;;   :dynamic    dynamic-case-code is evaluated with LOC bound to the cons
  128. X;;;               whose car holds the value of this dynamic slot, and NEWP
  129. X;;;               bound to t if the slot was just created and nil otherwise.
  130. X;;;   :class      class-case-code is evaluated with slotd bound to the slotd
  131. X;;;               of the slot.
  132. X;;; If the slot is not found.
  133. X;;;   If createp is t it is created and things proceed as in the allocation
  134. X;;;   :dynamic case.
  135. X;;; Otherwise, and if the allocation is nil the nil-case code is evaluated.
  136. X;;;               
  137. X(defmacro with-slot-internal--class ((class object slot-name createp)
  138. X                     &body cases)
  139. X  (let ((temp1 (gensym))
  140. X        (temp2 (gensym))
  141. X        (createp-var (gensym))
  142. X        (instance-case (cdr (assq :instance cases)))
  143. X        (dynamic-case (cdr (assq :dynamic cases)))
  144. X        (class-case (cdr (assq :class cases)))
  145. X        (nil-case (cdr (assq nil cases))))
  146. X    `(prog (,temp1                              ;The Horror! Its a PROG,
  147. X            ,temp2                              ;but its in a macro so..
  148. X            (,createp-var ,createp))
  149. X         (cond
  150. X           ((setq ,temp1 (slotd-position ,slot-name
  151. X                     (class-instance-slots ,class)))
  152. X            ;; We have the slots position in the instance slots.  Convert
  153. X        ;; that to the slots index and then cache the index and return
  154. X        ;; the result of evaluating the instance-case.
  155. X            (setq ,temp1 (%convert-slotd-position-to-slot-index ,temp1))
  156. X            (let ((wrapper (validate-class-wrapper ,object)))
  157. X              (class-wrapper-cache-cache-entry
  158. X                wrapper
  159. X                (class-wrapper-get-slot-offset wrapper ,slot-name)
  160. X                ,slot-name
  161. X                ,temp1))
  162. X            (return (let ,(and (car instance-case)
  163. X                   `((,(caar instance-case) ,temp1)))
  164. X                      . ,(cdr instance-case))))
  165. X           ((setq ,temp1 (slotd-assoc ,slot-name
  166. X                      (class-non-instance-slots ,class)))
  167. X            ;; We have a slotd -- this is some sort of declared slot.
  168. X            (ecase (slotd-allocation ,temp1)
  169. X              (:class      (return
  170. X                             (let ,(and (car class-case)
  171. X                                        `((,(caar class-case) ,temp1)))
  172. X                               . ,(cdr class-case))))
  173. X              ((:none nil) (go nil-case))
  174. X              (:dynamic    (setq ,createp-var :dynamic
  175. X                                 ,temp2       (slotd-default ,temp1))))))
  176. X         ;; When we get here, either:
  177. X         ;;  - we didn't find a slot-description for this slot, so try to
  178. X         ;;    find it in the dynamic slots creating it if createp-var is
  179. X         ;;    non-null.
  180. X         ;;  - we found a :dynamic slot-description, createp-var got set
  181. X         ;;    to :dynamic and we dropped through to here where we try
  182. X         ;;    to find the slot.  If we find it we return the loc.  If
  183. X         ;;    not we create it and initialize it to its default value.
  184. X         (multiple-value-setq (,temp1 ,createp-var)
  185. X           (dynamic-slot-loc--class ,object ,slot-name ,createp-var))
  186. X         (when ,temp1
  187. X           (when (and ,createp-var ,temp2)
  188. X             (setf (car ,temp1) (eval ,temp2)))
  189. X           (let
  190. X             (,@(and (caar dynamic-case) `((,(caar dynamic-case) ,temp1)))
  191. X              ,@(and (cadar dynamic-case) `((,(cadar dynamic-case)
  192. X                         ,createp-var))))
  193. X             (return . ,(cdr dynamic-case))))
  194. X      nil-case
  195. X         ;; This slot is either explicitly declared :allocation nil (we
  196. X         ;; jumped here by (GO NIL-CASE) or there is no declaration for
  197. X         ;; this slot and we didn't find it in the dynamic-slots, we fell
  198. X         ;; through from the dynamic lookup above.
  199. X         (let ,(and (car nil-case) `((,(caar nil-case) ,temp1)))
  200. X           . ,(cdr nil-case)))))
  201. X
  202. X(defun dynamic-slot-loc--class (object slot-name createp)
  203. X  (let ((plist (iwmc-class-dynamic-slots object)))
  204. X    (or (iterate ((prop on plist by cddr))
  205. X          (when (eq (car prop) slot-name) (return (cdr prop))))
  206. X        (and createp
  207. X             (values (cdr (setf (iwmc-class-dynamic-slots object)
  208. X                                (list* slot-name () plist)))
  209. X                     createp)))))
  210. X
  211. X(defun get-slot-using-class--class-internal (class object slot-name
  212. X                                                   dont-call-slot-missing-p
  213. X                           default)
  214. X  (with-slot-internal--class (class object slot-name nil)
  215. X    (:instance (index) (get-static-slot--class object index))
  216. X    (:dynamic (loc newp) (if (eq newp t) (setf (car loc) default) (car loc)))
  217. X    (:class (slotd) (slotd-default slotd))
  218. X    (nil () (unless dont-call-slot-missing-p
  219. X          (slot-missing object slot-name)))))
  220. X
  221. X(defun put-slot-using-class--class-internal (class object slot-name new-value
  222. X                                                   dont-call-slot-missing-p)
  223. X  (with-slot-internal--class
  224. X      (class object slot-name dont-call-slot-missing-p)
  225. X    (:instance (index) (setf (get-static-slot--class object index)
  226. X                 new-value))
  227. X    (:dynamic (loc) (setf (car loc) new-value))
  228. X    (:class (slotd) (setf (slotd-default slotd) new-value))
  229. X    (nil () (unless dont-call-slot-missing-p
  230. X          (slot-missing object slot-name)))))
  231. X
  232. X(defun all-slots (object)
  233. X  (all-slots-using-class (class-of object) object))
  234. X
  235. X(defmeth all-slots-using-class ((class basic-class) object)
  236. X  (append (iterate ((slotd in (class-instance-slots class)))
  237. X            (collect (slotd-name slotd))
  238. X            (collect (get-slot--class object (slotd-name slotd))))
  239. X          (iwmc-class-dynamic-slots object)))
  240. X
  241. X(defmeth remove-dynamic-slot-using-class ((class basic-class) object
  242. X                                  slot-name)
  243. X  (ignore class)
  244. X  (remove-dynamic-slot--class object slot-name))
  245. X
  246. X(defun slot-allocation (object slot-name)
  247. X  (slot-allocation-using-class (class-of object) object slot-name))
  248. X
  249. X(defmeth slot-allocation-using-class ((class basic-class) object slot-name)
  250. X  (with-slot-internal--class (class object slot-name nil)
  251. X    (:instance () :instance)
  252. X    (:dynamic () :dynamic)
  253. X    (:class () :class)
  254. X    (nil    () nil)))
  255. X
  256. X(defun slot-exists-p (object slot-name)
  257. X  (let* ((flag "")
  258. X         (val
  259. X       (get-slot-using-class (class-of object) object slot-name t flag)))
  260. X    (neq val flag)))
  261. X
  262. X(defmeth slot-missing (object slot-name)
  263. X  (error "The slot: ~S is missing from the object: ~S" slot-name object))
  264. X
  265. X(defmacro typep--class (iwmc-class type)
  266. X  `(not (null (memq (class-named ,type ())
  267. X                    (class-class-precedence-list 
  268. X                      (class-wrapper-class
  269. X                        (iwmc-class-class-wrapper ,iwmc-class)))))))
  270. X
  271. X(defmacro type-of--class (iwmc-class)
  272. X  `(class-name
  273. X     (class-wrapper-wrapped-class (iwmc-class-class-wrapper ,iwmc-class))))
  274. X
  275. X(defun subclassp (class1 class2)
  276. X  (or (classp class1) (setq class1 (class-named class1)))
  277. X  (or (classp class2) (setq class2 (class-named class2)))
  278. X  (memq class2 (class-class-precedence-list class1)))
  279. X
  280. X(defun sub-class-p (x class)
  281. X  (if (symbolp class) (setq class (class-named class)))
  282. X  (not (null (memq class (class-class-precedence-list (class-of x))))))
  283. X
  284. X
  285. X(defmeth class-has-instances-p ((class basic-class))
  286. X  (class-wrapper class))
  287. X
  288. X(defmeth make-instance ((class basic-class))
  289. X  (let ((class-wrapper (class-wrapper class)))
  290. X    (if class-wrapper                           ;Are there any instances?
  291. X        ;; If there are instances, the class is OK, just go ahead and
  292. X        ;; make the instance.
  293. X        (let ((instance (%allocate-instance--class
  294. X                          (class-no-of-instance-slots class))))
  295. X          (setf (iwmc-class-class-wrapper instance) class-wrapper)
  296. X          instance)
  297. X        ;; Do first make-instance-time error-checking, build the class
  298. X        ;; wrapper and call ourselves again to really build the instance.
  299. X        (progn
  300. X          ;; no first time error checking yet.
  301. X          (setf (class-wrapper class) (make-class-wrapper class))
  302. X          (make-instance class)))))
  303. X
  304. X(defun make (class &rest init-plist)
  305. X  (when (symbolp class) (setq class (class-named class)))
  306. X  (let ((object (make-instance class)))
  307. X    (initialize object init-plist)
  308. X    object))
  309. X
  310. X(defmeth initialize ((object object) init-plist)
  311. X  (initialize-from-defaults object)
  312. X  (initialize-from-init-plist object init-plist))
  313. X
  314. X(defmeth initialize-from-defaults ((self object))
  315. X  (iterate ((slotd in (class-instance-slots (class-of self))))
  316. X    (setf (get-slot self (slotd-name slotd)) (eval (slotd-default slotd)))))
  317. X
  318. X(defmeth initialize-from-init-plist ((self object) init-plist)
  319. X  (when init-plist
  320. X    (let* ((class (class-of self))
  321. X       (instance-slots (class-instance-slots class))
  322. X       (non-instance-slots (class-non-instance-slots class)))
  323. X      (flet ((find-slotd (keyword)
  324. X           (flet ((find-internal (slotds)
  325. X            (dolist (slotd slotds)
  326. X              (when (eq (slotd-keyword slotd) keyword)
  327. X                (return slotd)))))
  328. X         (or (find-internal instance-slots)
  329. X             (find-internal non-instance-slots)))))
  330. X    (do* ((keyword-loc init-plist (cdr value-loc))
  331. X          (value-loc (cdr keyword-loc) (cdr keyword-loc))
  332. X          (slotd () ())
  333. X          (allow-other-keys-p () allow-other-keys-p))
  334. X         (())
  335. X      (flet ((allow-other-keywords-p ()
  336. X           (when (null allow-other-keys-p)
  337. X             (setq allow-other-keys-p
  338. X               (do ((loc keyword-loc (cddr loc)))
  339. X                   ((null loc) 0)
  340. X                 (when (eq (car loc) ':allow-other-keys)
  341. X                   (if (cadr loc) 1 0)))))
  342. X           (if (= allow-other-keys-p 1) t nil)))
  343. X        (cond ((null keyword-loc) (return nil))
  344. X          ((eq (car keyword-loc) :allow-other-keys)
  345. X           (setq allow-other-keys-p
  346. X             (if (cadr keyword-loc) 1 0)))
  347. X          ((null value-loc)
  348. X           (error "No value supplied for the init-keyword ~S."
  349. X              (car keyword-loc)))
  350. X          ((null (setq slotd (find-slotd (car keyword-loc))))
  351. X           (unless (allow-other-keywords-p)
  352. X             (error "~S is not a valid keyword in the init-plist."
  353. X                (car keyword-loc))))
  354. X          (t
  355. X           (setf (get-slot self (slotd-name slotd))
  356. X             (car value-loc))))))))))
  357. X
  358. X
  359. X
  360. X(defmeth class-default-includes ((class basic-class))
  361. X  (ignore class)
  362. X  (list 'object))
  363. X
  364. END_OF_FILE
  365. if test 14319 -ne `wc -c <'class-slots.l'`; then
  366.     echo shar: \"'class-slots.l'\" unpacked with wrong size!
  367. fi
  368. # end of 'class-slots.l'
  369. fi
  370. if test -f 'defclass.l' -a "${1}" != "-c" ; then 
  371.   echo shar: Will not clobber existing file \"'defclass.l'\"
  372. else
  373. echo shar: Extracting \"'defclass.l'\" \(13381 characters\)
  374. sed "s/^X//" >'defclass.l' <<'END_OF_FILE'
  375. X;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  376. X;;;
  377. X;;; *************************************************************************
  378. X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  379. X;;;
  380. X;;; Use and copying of this software and preparation of derivative works
  381. X;;; based upon this software are permitted.  Any distribution of this
  382. X;;; software or derivative works must comply with all applicable United
  383. X;;; States export control laws.
  384. X;;; 
  385. X;;; This software is made available AS IS, and Xerox Corporation makes no
  386. X;;; warranty about the software, its performance or its conformity to any
  387. X;;; specification.
  388. X;;; 
  389. X;;; Any person obtaining a copy of this software is requested to send their
  390. X;;; name and post office or electronic mail address to:
  391. X;;;   CommonLoops Coordinator
  392. X;;;   Xerox Artifical Intelligence Systems
  393. X;;;   2400 Hanover St.
  394. X;;;   Palo Alto, CA 94303
  395. X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  396. X;;;
  397. X;;; Suggestions, comments and requests for improvements are also welcome.
  398. X;;; *************************************************************************
  399. X;;;
  400. X
  401. X(in-package 'pcl)
  402. X
  403. X
  404. X  ;;   
  405. X;;;;;; New New Minglewood Blues
  406. X  ;;   the new "legendary macro itself"
  407. X;;;
  408. X(defmacro ndefstruct (name-and-options &rest slot-descriptions)
  409. X  ;;
  410. X  ;; The defstruct macro does some pre-processing on name-and-options and
  411. X  ;; slot-descriptions before it passes them on to expand-defstruct. It
  412. X  ;; also pulls out the documentation string (if there is one) and passes
  413. X  ;; it to expand defstruct as a separate argument.
  414. X  ;;
  415. X  ;; The main reason for doing this is that it imposes more uniformity in
  416. X  ;; the syntax of defstructs for different metaclasses, and it puts some
  417. X  ;; useful error checking for that syntax in one central place.
  418. X  ;; 
  419. X  (let ((documentation (and (stringp (car slot-descriptions))
  420. X                (pop slot-descriptions))))
  421. X    (or (listp name-and-options) (setq name-and-options (list name-and-options)))
  422. X    (setq slot-descriptions
  423. X          (iterate ((sd in slot-descriptions))
  424. X            (collect
  425. X              (cond ((not (listp sd)) (list sd nil))
  426. X                    (t (unless (evenp (length sd))
  427. X                         (error "While parsing the defstruct ~S, the slot-description: ~S~%~
  428. X                                 has an odd number of elements."
  429. X                                (car name-and-options) sd))
  430. X                       sd)))))
  431. X    (keyword-parse ((class 'structure))
  432. X                   (cdr name-and-options)
  433. X      (let ((class-object (class-named class t)))
  434. X        (if class-object
  435. X            (expand-defstruct
  436. X              (class-prototype class-object) name-and-options documentation slot-descriptions)
  437. X            (error "The argument to defstruct's :class option was ~S;~%~
  438. X                    but there is no class named ~S."
  439. X                   class class))))))
  440. X
  441. X(defmacro defclass (name includes slots &rest options)
  442. X  (keyword-parse ((metaclass 'class)) options
  443. X    (let ((metaclass-object (class-named metaclass t)))
  444. X      (or metaclass-object 
  445. X      (error "The class option to defclass was ~S,~%~
  446. X                  but there is no class with that name."
  447. X         metaclass))
  448. X      (or (subclassp metaclass-object 'class)
  449. X      (error
  450. X        "The class specified in the :metaclass option to defclass, ~S,~%~
  451. X            is not a subclass of the class class."
  452. X        metaclass))
  453. X      (expand-defclass metaclass-object name includes slots options))))
  454. X
  455. X(defmethod expand-defclass ((metaclass class) name includes slots options)
  456. X  (keyword-parse ((accessor-prefix nil accessor-prefix-p)) options
  457. X    (when (and accessor-prefix-p
  458. X           (not (or (null accessor-prefix)
  459. X            (symbolp accessor-prefix))))
  460. X      (error "The :accessor-prefix option, when specified must have either~%~
  461. X              have an argument which is a symbol, or no argument at all."))
  462. X    (setq slots (iterate ((slot in slots))
  463. X          (collect
  464. X            (cond ((and (listp slot)
  465. X                (cddr slot))
  466. X               (let ((initform
  467. X                   (if (memq :initform (cdr slot))
  468. X                       (cadr (memq :initform (cdr slot)))
  469. X                       *slotd-unsupplied*)))
  470. X                 (list* (car slot) initform (cdr slot))))
  471. X              ((listp slot) slot)
  472. X              (t (list slot *slotd-unsupplied*))))))
  473. X    `(ndefstruct (,name (:class ,(class-name metaclass))
  474. X            (:include ,includes)
  475. X            ,@(and accessor-prefix-p
  476. X                   `((:conc-name ,accessor-prefix)))
  477. X            (:generate-accessors ,(and accessor-prefix-p
  478. X                           'method))
  479. X            ,@options)
  480. X     ,@slots)))
  481. X
  482. X(defmeth expand-defstruct ((class basic-class) name-and-options documentation slot-descriptions)
  483. X  (ignore documentation)
  484. X  (let* ((name (car name-and-options))
  485. X         (ds-options (parse-defstruct-options class name (cdr name-and-options)))
  486. X         (slotds (parse-slot-descriptions class ds-options slot-descriptions)))
  487. X    `(progn
  488. X       (eval-when (load eval)     
  489. X     (record-definition ',name 'ndefstruct))
  490. X       ;; Start by calling add-named-class which will actually define the new
  491. X       ;; class, updating the class lattice obsoleting old instances etc.
  492. X       (eval-when (compile load eval)
  493. X         (add-named-class
  494. X       (class-prototype (class-named ',(class-name (class-of class))))
  495. X       ',name
  496. X       ',(or (ds-options-includes ds-options)
  497. X         (class-default-includes class))
  498. X       ',slotds
  499. X       ',ds-options))
  500. X       ,@(expand-defstruct-make-definitions class name ds-options slotds)
  501. X       ',name)))
  502. X
  503. X(defmeth expand-defstruct-make-definitions ((class basic-class)
  504. X                         name ds-options slotds)
  505. X  (append (make-accessor-definitions class name ds-options slotds)
  506. X          (make-constructor-definitions class name ds-options slotds)
  507. X          (make-copier-definitions class name ds-options slotds)
  508. X          (make-predicate-definitions class name ds-options slotds)
  509. X          (make-print-function-definitions class name ds-options slotds)))
  510. X
  511. X(define-function-template iwmc-class-accessor () '(slot-name)
  512. X  `(function (lambda (iwmc-class) (get-slot--class iwmc-class slot-name))))
  513. X
  514. X(eval-when (load)
  515. X  (pre-make-templated-function-constructor iwmc-class-accessor))
  516. X
  517. X(define-function-template iwmc-class-accessor-setf (read-only-p) '(slot-name)
  518. X  (if read-only-p
  519. X      `(function
  520. X         (lambda (iwmc-class new-value)
  521. X       (error "~S is a read only slot." slot-name)))
  522. X      `(function
  523. X         (lambda (iwmc-class new-value)
  524. X       (put-slot--class iwmc-class slot-name new-value)))))
  525. X
  526. X
  527. X(eval-when (load)
  528. X  (pre-make-templated-function-constructor iwmc-class-accessor-setf nil)
  529. X  (pre-make-templated-function-constructor iwmc-class-accessor-setf t))
  530. X
  531. X(defmethod make-iwmc-class-accessor ((ignore class) slotd)
  532. X  (funcall (get-templated-function-constructor 'iwmc-class-accessor)
  533. X       (slotd-name slotd)))
  534. X
  535. X(defmethod make-iwmc-class-accessor-setf ((ignore class) slotd)
  536. X  (funcall
  537. X    (get-templated-function-constructor 'iwmc-class-accessor-setf
  538. X                    (slotd-read-only slotd))
  539. X    (slotd-name slotd)))
  540. X
  541. X(defun add-named-method-early (discriminator-name
  542. X                   arglist
  543. X                   argument-specifiers
  544. X                   function)
  545. X  (if (null *real-methods-exist-p*)
  546. X      (unless (memq discriminator-name *protected-early-selectors*)
  547. X    (setf (symbol-function discriminator-name) function))
  548. X      (add-named-method (class-prototype (class-named 'discriminator))
  549. X            (class-prototype (class-named 'method))
  550. X            discriminator-name
  551. X            arglist
  552. X            argument-specifiers
  553. X            ()
  554. X            function)))
  555. X  
  556. X(defmeth make-accessor-definitions
  557. X     ((class basic-class) name ds-options slotds)
  558. X  (ignore class ds-options)
  559. X  (cons `(do-accessor-definitions ',name ',slotds)
  560. X    (iterate ((slotd in slotds))
  561. X      (let ((accessor (slotd-accessor slotd))
  562. X        setf-discriminator-name)
  563. X        (when accessor
  564. X          (setq setf-discriminator-name
  565. X            (make-setf-discriminator-name accessor))
  566. X          (compile-time-define 'defun accessor)
  567. X          (compile-time-define 'defun setf-discriminator-name)
  568. X          (compile-time-define 'defsetf accessor setf-discriminator-name)
  569. X          (collect `(defsetf ,accessor ,setf-discriminator-name)))))))
  570. X
  571. X(defun do-accessor-definitions (name slotds)
  572. X  (let ((class (class-named name))
  573. X    (accessor nil)
  574. X    (setf-discriminator-name nil))
  575. X    (dolist (slotd slotds)
  576. X      (when (setq accessor (slotd-accessor slotd))
  577. X    (setq setf-discriminator-name
  578. X          (make-setf-discriminator-name accessor))
  579. X    (unless *real-methods-exist-p*
  580. X      (record-early-discriminator accessor)
  581. X      (record-early-discriminator setf-discriminator-name))
  582. X    (add-named-method-early accessor
  583. X                `(,name)
  584. X                `(,class)
  585. X                (or (slotd-get-function slotd)
  586. X                    (make-iwmc-class-accessor class slotd)))
  587. X    (add-named-method-early setf-discriminator-name
  588. X                `(,name new-value)
  589. X                `(,class)
  590. X                (or (slotd-put-function slotd)
  591. X                    (make-iwmc-class-accessor-setf class
  592. X                                   slotd)))))
  593. X    (unless *real-methods-exist-p*
  594. X      (record-early-method-fixup
  595. X    `(let ((*real-methods-exist-p* t))
  596. X       (do-accessor-definitions ',name ',slotds))))))
  597. X
  598. X(defmeth make-constructor-definitions ((class basic-class) name ds-options slotds)
  599. X  (ignore class slotds)
  600. X  (let ((constructors (ds-options-constructors ds-options)))
  601. X    (iterate ((constructor in constructors))
  602. X      (when (car constructor)
  603. X        (collect
  604. X          (if (cdr constructor)
  605. X              `(defun ,(car constructor) ,(cadr constructor)
  606. X                 (make ',name ,@(iterate ((slot-name in (cadr constructor)))
  607. X                                         (unless (memq slot-name
  608. X                                                       '(&optional &rest &aux))
  609. X                                           (collect `',(make-keyword slot-name))
  610. X                                           (collect slot-name)))))
  611. X              `(defun ,(car constructor) (&rest init-plist)
  612. X                 (apply #'make ',name init-plist))))))))
  613. X
  614. X(define-function-template copier--class () ()
  615. X  `(function
  616. X     (lambda (iwmc-class)
  617. X       (let* ((class (class-of iwmc-class))
  618. X              (to (make-instance (class-of iwmc-class)))
  619. X              (from-static (iwmc-class-static-slots iwmc-class))        
  620. X              (to-static (iwmc-class-static-slots to))
  621. X              (static-slots (class-instance-slots class)))
  622. X         (do ((i 0 (+ i 1))
  623. X          (index nil index)         
  624. X              (x static-slots (cdr x)))
  625. X             ((null x))
  626. X       (setq index (%convert-slotd-position-to-slot-index i))
  627. X           (setf (%static-slot-storage-get-slot--class to-static index)
  628. X                 (%static-slot-storage-get-slot--class from-static index)))
  629. X         (setf (iwmc-class-dynamic-slots to)
  630. X               (copy-list (iwmc-class-dynamic-slots iwmc-class)))
  631. X         to))))
  632. X
  633. X(eval-when (load)
  634. X  (pre-make-templated-function-constructor copier--class))
  635. X
  636. X(defmeth make-copier-definitions ((class basic-class) name ds-options slotds)
  637. X  (ignore class slotds)
  638. X  (let ((copier (ds-options-copier ds-options)))    
  639. X    (when copier
  640. X      (compile-time-define 'defun copier)
  641. X      `((do-copier-definition ',name ',copier)))))
  642. X
  643. X(defun do-copier-definition (class-name copier-name)
  644. X  (unless *real-methods-exist-p*
  645. X    (record-early-discriminator copier-name)
  646. X    (record-early-method-fixup
  647. X      `(let ((*real-methods-exist-p* t))
  648. X     (do-copier-definition ',class-name ',copier-name))))
  649. X  (add-named-method-early copier-name
  650. X              `(,class-name)
  651. X              `(,(class-named class-name))
  652. X              (funcall
  653. X                (get-templated-function-constructor
  654. X                  'copier--class))))
  655. X
  656. X(define-function-template iwmc-class-predicate () '(class-name)
  657. X  `(function (lambda (x)
  658. X           (and (iwmc-class-p x)
  659. X            (typep--class x class-name)))))
  660. X
  661. X(eval-when (load)
  662. X  (pre-make-templated-function-constructor iwmc-class-predicate))
  663. X
  664. X(defmeth make-predicate-definitions ((class basic-class)
  665. X                     name ds-options slotds)
  666. X  (ignore class slotds)
  667. X  (let ((predicate (or (ds-options-predicate ds-options)
  668. X                       (make-symbol (string-append name " Predicate")))))
  669. X    (compile-time-define 'defun predicate)
  670. X    `((do-predicate-definition ',name ',predicate)
  671. X      (deftype ,name () '(satisfies ,predicate)))))
  672. X
  673. X(defun do-predicate-definition (class-name predicate-name)
  674. X  (setf (symbol-function predicate-name)
  675. X    (funcall (get-templated-function-constructor 'iwmc-class-predicate)
  676. X         class-name)))
  677. X
  678. X(defun make-print-function-definitions
  679. X      (class name ds-options slotds)
  680. X  (ignore class slotds)
  681. X  (let* ((print-function (ds-options-print-function ds-options))
  682. X     (arglist ())
  683. X     (defun ())
  684. X     (defun-name ()))
  685. X    (when print-function
  686. X      (cond ((symbolp print-function)
  687. X         (setq arglist '(object stream depth)))
  688. X        ((and (listp print-function) (eq (car print-function) 'lambda))
  689. X         (setq arglist (cadr print-function)
  690. X           defun-name (intern 
  691. X                (string-append (symbol-name name)
  692. X                           " Print Function"))
  693. X           defun `(defun ,defun-name ,arglist
  694. X                ,@(cddr print-function))
  695. X           print-function defun-name))
  696. X        (t
  697. X         (error "Internal error, make-print-function-definitions can't~%~
  698. X                     understand the contents of the print-function slot of~%~
  699. X                     the ds-options.")))
  700. X      `(,defun
  701. X    (do-print-function-definitions ',name ',arglist ',print-function)))))
  702. X
  703. X(defun do-print-function-definitions (name arglist print-function)
  704. X  (unless *real-methods-exist-p*
  705. X    (record-early-method-fixup
  706. X      `(let ((*real-methods-exist-p* t))
  707. X     (do-print-function-definitions ',name ',arglist ',print-function))))
  708. X  (add-named-method-early 'print-instance
  709. X              arglist
  710. X              (list (class-named name))
  711. X              print-function))
  712. X
  713. END_OF_FILE
  714. if test 13381 -ne `wc -c <'defclass.l'`; then
  715.     echo shar: \"'defclass.l'\" unpacked with wrong size!
  716. fi
  717. # end of 'defclass.l'
  718. fi
  719. if test -f 'fsc-low.l' -a "${1}" != "-c" ; then 
  720.   echo shar: Will not clobber existing file \"'fsc-low.l'\"
  721. else
  722. echo shar: Extracting \"'fsc-low.l'\" \(13302 characters\)
  723. sed "s/^X//" >'fsc-low.l' <<'END_OF_FILE'
  724. X;;;-*-Mode:LISP; Package:(PCL (LISP WALKER) 1000); Base:10; Syntax:Common-lisp -*-
  725. X;;;
  726. X;;; *************************************************************************
  727. X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  728. X;;;
  729. X;;; Use and copying of this software and preparation of derivative works
  730. X;;; based upon this software are permitted.  Any distribution of this
  731. X;;; software or derivative works must comply with all applicable United
  732. X;;; States export control laws.
  733. X;;; 
  734. X;;; This software is made available AS IS, and Xerox Corporation makes no
  735. X;;; warranty about the software, its performance or its conformity to any
  736. X;;; specification.
  737. X;;; 
  738. X;;; Any person obtaining a copy of this software is requested to send their
  739. X;;; name and post office or electronic mail address to:
  740. X;;;   CommonLoops Coordinator
  741. X;;;   Xerox Artifical Intelligence Systems
  742. X;;;   2400 Hanover St.
  743. X;;;   Palo Alto, CA 94303
  744. X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  745. X;;;
  746. X;;; Suggestions, comments and requests for improvements are also welcome.
  747. X;;; *************************************************************************
  748. X;;;
  749. X
  750. X#|  To do:
  751. X
  752. Xfigure out bootstrapping issues
  753. X
  754. Xfix problems caused by make-iwmc-class-accessor
  755. X
  756. Xpolish up the low levels of iwmc-class, 
  757. X
  758. Xfix use of get-slot-using-class--class-internal
  759. X
  760. X|#
  761. X  ;;   
  762. X;;;;;; FUNCALLABLE INSTANCES
  763. X  ;;
  764. X
  765. X#|
  766. X
  767. XIn CommonLoops, generic functions are instances whose meta class is
  768. Xfuncallable-standard-class.  Instances with this meta class behave
  769. Xsomething like lexical closures in that they have slots, just like
  770. Xinstances with meta class standard-class, and are also funcallable.
  771. XWhen an instance with meta class funcallable-standard-class is
  772. Xfuncalled, the value of its function slot is called.
  773. X
  774. XIt is possible to implement funcallable instances in pure Common Lisp.
  775. XA simple implementation which uses lexical closures as the instances and
  776. Xa hash table to record that the lexical closures are funcallable
  777. Xinstances is easy to write.  Unfortunately, this implementation adds
  778. Xsuch significant overhead:
  779. X
  780. X   to generic-function-invocation (1 function call)
  781. X   to slot-access (1 function call)
  782. X   to class-of a generic-function (1 hash-table lookup)
  783. X
  784. XIn other words, it is too slow to be practical.
  785. X
  786. XInstead, PCL uses a specially tailored implementation for each common
  787. XLisp and makes no attempt to provide a purely portable implementation.
  788. XThe specially tailored implementations are based on each the lexical
  789. Xclosure's provided by that implementation and tend to be fairly easy to
  790. Xwrite.
  791. X
  792. X|#
  793. X
  794. X(in-package 'pcl)
  795. X
  796. X;;;
  797. X;;; The first part of the file contains the implementation dependent code
  798. X;;; to implement the low-level funcallable instances.  Each implementation
  799. X;;; must provide the following functions and macros:
  800. X;;; 
  801. X;;;    MAKE-FUNCALLABLE-INSTANCE-1 ()
  802. X;;;       should create and return a new funcallable instance
  803. X;;;
  804. X;;;    FUNCALLABLE-INSTANCE-P (x)
  805. X;;;       the obvious predicate
  806. X;;;
  807. X;;;    SET-FUNCALLABLE-INSTANCE-FUNCTION-1 (fin new-value)
  808. X;;;       change the fin so that when it is funcalled, the new-value
  809. X;;;       function is called.  Note that it is legal for new-value
  810. X;;;       to be copied before it is installed in the fin (the Lucid
  811. X;;;       implementation in particular does this).
  812. X;;;
  813. X;;;    FUNCALLABLE-INSTANCE-DATA-1 (fin data-name)
  814. X;;;       should return the value of the data named data-name in the fin
  815. X;;;       data-name is one of the symbols in the list which is the value
  816. X;;;       of funcallable-instance-data.  Since data-name is almost always
  817. X;;;       a quoted symbol and funcallable-instance-data is a constant, it
  818. X;;;       is possible (and worthwhile) to optimize the computation of
  819. X;;;       data-name's offset in the data part of the fin.
  820. X;;;       
  821. X
  822. X(defconstant funcallable-instance-data
  823. X         '(class wrapper static-slots dynamic-slots)
  824. X  "These are the 'data-slots' which funcallable instances have so that
  825. X   the meta-class funcallable-standard-class can store class, and static
  826. X   and dynamic slots in them.")
  827. X
  828. X#+Lucid
  829. X(progn
  830. X  
  831. X(defconstant funcallable-instance-procedure-size 50)
  832. X(defconstant funcallable-instance-flag-bit #B1000000000000000)
  833. X(defvar *funcallable-instance-trampolines* ()
  834. X  "This is a list of all the procedure sizes which were too big to be stored
  835. X   directly in a funcallable instance.  For each of these procedures, a
  836. X   trampoline procedure had to be used.  This is for metering information
  837. X   only.")
  838. X
  839. X(defun make-funcallable-instance-1 ()
  840. X  (let ((new-fin (lucid::new-procedure funcallable-instance-procedure-size)))
  841. X    ;; Have to set the procedure function to something for two reasons.
  842. X    ;;   1. someone might try to funcall it.
  843. X    ;;   2. the flag bit that says the procedure is a funcallable
  844. X    ;;      instance is set by set-funcallable-instance-function.
  845. X    (set-funcallable-instance-function
  846. X      new-fin
  847. X      #'(lambda (&rest ignore)
  848. X      (declare (ignore ignore))
  849. X      (error "Attempt to funcall a funcallable-instance without first~%~
  850. X                  setting its funcallable-instance-function.")))
  851. X    new-fin))
  852. X
  853. X(defmacro funcallable-instance-p (x)
  854. X  (once-only (x)
  855. X    `(and (lucid::procedurep ,x)
  856. X      (logand (lucid::procedure-ref ,x lucid::procedure-flags)
  857. X          funcallable-instance-flag-bit))))
  858. X
  859. X(defun set-funcallable-instance-function-1 (fin new-value)
  860. X  (unless (funcallable-instance-p fin)
  861. X    (error "~S is not a funcallable-instance"))
  862. X  (cond ((not (functionp new-value))
  863. X     (error "~S is not a function."))
  864. X    ((not (lucid::procedurep new-value))
  865. X     ;; new-value is an interpreted function.  Install a
  866. X     ;; trampoline to call the interpreted function.
  867. X     (set-funcallable-instance-function fin
  868. X                        (make-trampoline new-value)))
  869. X    (t
  870. X     (let ((new-procedure-size (lucid::procedure-length new-value))
  871. X           (max-procedure-size (- funcallable-instance-procedure-size
  872. X                      (length funcallable-instance-data))))
  873. X       (if (< new-procedure-size max-procedure-size)
  874. X           ;; The new procedure fits in the funcallable-instance.
  875. X           ;; Just copy the new procedure into the fin procedure,
  876. X           ;; also be sure to update the procedure-flags of the
  877. X           ;; fin to keep it a fin.
  878. X           (progn 
  879. X         (dotimes (i max-procedure-size)
  880. X           (setf (lucid::procedure-ref fin i)
  881. X             (lucid::procedure-ref new-value i)))
  882. X         (setf (lucid::procedure-ref fin lucid::procedure-flags)
  883. X               (logand funcallable-instance-flag-bit
  884. X                   (lucid::procedure-ref
  885. X                 fin lucid::procedure-flags)))
  886. X         new-value)
  887. X           ;; The new procedure doesn't fit in the funcallable instance
  888. X           ;; Instead, install a trampoline procedure which will call
  889. X           ;; the new procecdure.  First make note of the fact that we
  890. X           ;; had to trampoline so that we can see if its worth upping
  891. X           ;; the value of funcallable-instance-procedure-size.
  892. X           (progn
  893. X         (push new-procedure-size *funcallable-instance-trampolines*)
  894. X         (set-funcallable-instance-function
  895. X           fin
  896. X           (make-trampoline new-value))))))))
  897. X
  898. X
  899. X(defmacro funcallable-instance-data-1 (instance data)
  900. X  `(lucid::procedure-ref ,instance
  901. X             (- funcallable-instance-procedure-size
  902. X                (position ,data funcallable-instance-data))))
  903. X  
  904. X);dicuL+#
  905. X
  906. X;;;
  907. X;;; All of these Lisps (Xerox Symbolics ExCL KCL and VAXLisp) have the
  908. X;;; following in Common:
  909. X;;; 
  910. X;;;    - they represent their compiled closures as a pair of
  911. X;;;      environment and compiled function
  912. X;;;    - they represent the environment using a list or a vector
  913. X;;;    - I don't (YET) know how to add a bit to the damn things to
  914. X;;;      say that they are funcallable-instances and so I have to
  915. X;;;      use the last entry in the closure environment to do that.
  916. X;;;      This is a lose because that is much slower, I have to CDR
  917. X;;;      down to the last element of the environment.
  918. X;;;      
  919. X#+(OR Xerox Symbolics ExCL KCL (and DEC VAX))
  920. X(progn
  921. X
  922. X(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
  923. X
  924. X(defconstant funcallable-instance-closure-size 15)
  925. X
  926. X(defmacro lexical-closure-p (lc)
  927. X  #+Xerox         `(typep ,lc 'il:compiled-closure)
  928. X  #+Symbolics     `(si:lexical-closure-p ,lc)
  929. X  #+ExCL          `()
  930. X  #+KCL           `()
  931. X  #+(and DEC VAX) (once-only (lc)
  932. X            `(and (listp ,lc)
  933. X              (eq (car ,lc) 'system::%compiled-closure%))))
  934. X
  935. X(defmacro lexical-closure-env (lc)
  936. X  #+Xerox         `()
  937. X  #+Symbolics     `(si:lexical-closure-environment ,lc)
  938. X  #+ExCL          `()
  939. X  #+KCL           `()
  940. X  #+(and DEC VAX) `(caadr ,lc))
  941. X
  942. X(defmacro lexical-closure-env-size (env)
  943. X  #+Xerox         `()
  944. X  #+Symbolics     `(length ,env)
  945. X  #+ExCL          `()
  946. X  #+KCL           `()
  947. X  #+(and DEC VAX) `(array-dimension ,env 0))  
  948. X
  949. X(defmacro lexical-closure-env-ref (env index check) check
  950. X  #+Xerox         `()
  951. X  #+Symbolics     `(let ((env ,env))
  952. X             (dotimes (i ,index)
  953. X               (setq env (cdr env)))
  954. X             (car env))
  955. X  #+ExCL          `()
  956. X  #+KCL           `()
  957. X  #+(and DEC VAX) (once-only (env)
  958. X            `(and ,(or checkp
  959. X                   `(= (array-dimension ,env 0)
  960. X                   funcallable-instance-closure-size))
  961. X              (svref ,env 0))))
  962. X
  963. X(defmacro lexical-closure-env-set (env index new checkp) checkp
  964. X  #+Xerox         `()
  965. X  #+Symbolics     `(let ((env ,env))
  966. X             (dotimes (i ,index)
  967. X               (setq env (cdr env)))
  968. X             (setf (car env) ,new))
  969. X  #+ExCL          `()
  970. X  #+KCL           `()
  971. X  #+(and DEC VAX) (once-only (env)
  972. X            `(and ,(or checkp
  973. X                   `(= (array-dimension ,env 0)
  974. X                   funcallable-instance-closure-size))
  975. X              (setf (svref ,env ,index) ,new))))
  976. X
  977. X(defmacro lexical-closure-code (lc)
  978. X  #+Xerox         `()
  979. X  #+Symbolics     `(si:lexical-closure-function ,lc)
  980. X  #+ExCL          `()
  981. X  #+KCL           `()
  982. X  #+(and DEC VAX) `(caddr ,lc))
  983. X
  984. X(defmacro compiled-function-code (cf)  
  985. X  #+Xerox         `()
  986. X  #+Symbolics     cf
  987. X  #+ExCL          `()
  988. X  #+KCL           `()
  989. X  #+(and DEC VAX) `())
  990. X
  991. X(eval-when (load eval)
  992. X  (let ((dummies ()))
  993. X    (dotimes (i funcallable-instance-closure-size)
  994. X      (push (gentemp "Dummy Closure Variable ") dummies))
  995. X    (compile 'make-funcallable-instance-1    ;For the time being, this use
  996. X         `(lambda ()            ;of compile at load time is
  997. X        (let (new-fin ,@dummies)    ;simpler than using #.
  998. X          (setq new-fin #'(lambda ()
  999. X                    ,@(mapcar #'(lambda (d)
  1000. X                          `(setq ,d (dummy-fn ,d)))
  1001. X                          dummies)))
  1002. X          (lexical-closure-env-set
  1003. X            (lexical-closure-env new-fin)
  1004. X            (1- funcallable-instance-closure-size)
  1005. X            *funcallable-instance-marker*
  1006. X            t)
  1007. X          new-fin)))))
  1008. X
  1009. X(defmacro funcallable-instance-p (x)
  1010. X  (once-only (x)
  1011. X    `(and (lexical-closure-p ,x)
  1012. X      (let ((env (lexical-closure-env ,x)))
  1013. X        (and (eq (lexical-closure-env-ref
  1014. X               env (1- funcallable-instance-closure-size) t)
  1015. X             *funcallable-instance-marker*))))))
  1016. X
  1017. X(defun set-funcallable-instance-function-1 (fin new-value)
  1018. X  (cond ((lexical-closure-p new-value)
  1019. X     (let* ((fin-env (lexical-closure-env fin))
  1020. X        (new-env (lexical-closure-env new-value))
  1021. X        (new-env-size (lexical-closure-env-size new-env))
  1022. X        (fin-env-size (- funcallable-instance-closure-size
  1023. X                 (length funcallable-instance-data))))
  1024. X       (cond ((<= new-env-size fin-env-size)
  1025. X          (dotimes (i new-env-size)
  1026. X            (lexical-closure-env-set
  1027. X              fin-env i (lexical-closure-env-ref new-env i nil) nil))
  1028. X          (setf (lexical-closure-code fin)
  1029. X            (lexical-closure-code new-value)))
  1030. X         (t            
  1031. X          (set-funcallable-instance-function-1
  1032. X            fin (make-trampoline new-value))))))
  1033. X    (t
  1034. X     #+Symbolics
  1035. X     (set-funcallable-instance-function-1 fin
  1036. X                          (make-trampoline new-value))
  1037. X     #-Symbolics
  1038. X     (setf (lexical-closure-code fin)
  1039. X           (compiled-function-code new-value)))))
  1040. X    
  1041. X(defmacro funcallable-instance-data-1 (fin data)
  1042. X  `(lexical-closure-env-ref
  1043. X     (lexical-closure-env ,fin)
  1044. X     (- funcallable-instance-closure-size
  1045. X    (position ,data funcallable-instance-data)
  1046. X    2)
  1047. X     nil))
  1048. X
  1049. X(defsetf funcallable-instance-data-1 (fin data) (new-value)
  1050. X  `(lexical-closure-env-set
  1051. X     (lexical-closure-env ,fin)
  1052. X     (- funcallable-instance-closure-size
  1053. X    (position ,data funcallable-instance-data)
  1054. X    2)
  1055. X     ,new-value
  1056. X     nil))
  1057. X
  1058. X);
  1059. X
  1060. X
  1061. X(defun make-trampoline (function)
  1062. X  #'(lambda (&rest args)
  1063. X      (apply function args)))
  1064. X
  1065. X(defun set-funcallable-instance-function (fin new-value)
  1066. X  (cond ((not (funcallable-instance-p fin))
  1067. X     (error "~S is not a funcallable-instance"))
  1068. X    ((not (functionp new-value))
  1069. X     (error "~S is not a function."))
  1070. X    ((compiled-function-p new-value)
  1071. X     (set-funcallable-instance-function-1 fin new-value))
  1072. X    (t
  1073. X     (set-funcallable-instance-function-1 fin
  1074. X                          (make-trampoline new-value)))))
  1075. X
  1076. X
  1077. X(defmacro funcallable-instance-class (fin)
  1078. X  `(funcallable-instance-data-1 ,fin 'class))
  1079. X
  1080. X(defmacro funcallable-instance-wrapper (fin)
  1081. X  `(funcallable-instance-data-1 ,fin 'wrapper))
  1082. X
  1083. X(defmacro funcallable-instance-static-slots (fin)
  1084. X  `(funcallable-instance-data-1 ,fin 'static-slots))
  1085. X
  1086. X(defmacro funcallable-instance-dynamic-slots (fin)
  1087. X  `(funcallable-instance-data-1 ,fin 'dynamic-slots))
  1088. X
  1089. X(defun make-funcallable-instance (class wrapper number-of-static-slots)
  1090. X  (let ((fin (make-funcallable-instance-1))
  1091. X    (static-slots (make-memory-block number-of-static-slots))
  1092. X    (dynamic-slots ()))
  1093. X    (setf (funcallable-instance-class fin) class
  1094. X      (funcallable-instance-wrapper fin) wrapper
  1095. X      (funcallable-instance-static-slots fin) static-slots
  1096. X      (funcallable-instance-dynamic-slots fin) dynamic-slots)
  1097. X    fin))
  1098. X
  1099. END_OF_FILE
  1100. if test 13302 -ne `wc -c <'fsc-low.l'`; then
  1101.     echo shar: \"'fsc-low.l'\" unpacked with wrong size!
  1102. fi
  1103. # end of 'fsc-low.l'
  1104. fi
  1105. if test -f 'regress.l' -a "${1}" != "-c" ; then 
  1106.   echo shar: Will not clobber existing file \"'regress.l'\"
  1107. else
  1108. echo shar: Extracting \"'regress.l'\" \(17554 characters\)
  1109. sed "s/^X//" >'regress.l' <<'END_OF_FILE'
  1110. X
  1111. X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1112. X;
  1113. X; File:         regress.l
  1114. X; RCS:          $Revision: 1.1 $
  1115. X; SCCS:         %A% %G% %U%
  1116. X; Description:  Regression Tests for COOL.
  1117. X; Author:       James Kempf, HP/DCC
  1118. X; Created:      24-Feb-87
  1119. X; Modified:     25-Feb-87 08:45:24 (James Kempf)
  1120. X; Language:     Lisp
  1121. X; Package:      TEST
  1122. X;
  1123. X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1124. X;
  1125. X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
  1126. X;
  1127. X; Use and copying of this software and preparation of derivative works based
  1128. X; upon this software are permitted.  Any distribution of this software or
  1129. X; derivative works must comply with all applicable United States export
  1130. X; control laws.
  1131. X; 
  1132. X; This software is made available AS IS, and Hewlett-Packard Corporation makes
  1133. X; no warranty about the software, its performance or its conformity to any
  1134. X; specification.
  1135. X;
  1136. X; Suggestions, comments and requests for improvement may be mailed to
  1137. X; aiws@hplabs.HP.COM
  1138. X
  1139. X
  1140. X(provide "co-regress")
  1141. X
  1142. X(in-package 'test)
  1143. X
  1144. X(require "co")
  1145. X
  1146. X(require "co-test")
  1147. X
  1148. X(use-package 'co)
  1149. X
  1150. X
  1151. X
  1152. X;;Need the test macro from PCL
  1153. X
  1154. X(import
  1155. X  '(
  1156. X    pcl:do-test
  1157. X  )
  1158. X)
  1159. X
  1160. X;;This is needed to be sure the Lisp functions are
  1161. X;;  correctly redefined
  1162. X
  1163. X(import-specialized-functions)
  1164. X
  1165. X(do-test ("define-type" :return-value T)
  1166. X     (
  1167. X       (define-type car 
  1168. X         (:var name :gettable)
  1169. X         (:var top-speed :settable)
  1170. X         (:var turbo-p :initable)
  1171. X         :all-initable
  1172. X       )
  1173. X       car
  1174. X     )
  1175. X     ( (instancep 'car) NIL)
  1176. X     ( (typep 'car 'instance) NIL)
  1177. X)
  1178. X
  1179. X(do-test "make-instance"
  1180. X      (instancep (setq c (make-instance 'car :name 'porsche)))
  1181. X      (=> c :typep 'car)
  1182. X)
  1183. X
  1184. X(do-test ("make-instance error cases" :should-error T)
  1185. X      (make-instance NIL)
  1186. X      (make-instance (gensym))
  1187. X      (make-instance 'not-a-type)
  1188. X      (make-instance 'float)
  1189. X      (make-instance 'car :not-initkw 314159)
  1190. X)
  1191. X
  1192. X(do-test ("make-instance syntax" :should-error T)
  1193. X      (make-instance)
  1194. X      (make-instance '(a b))
  1195. X      (make-instance 'car :boink)
  1196. X      (make-instance 'car :name)
  1197. X      (make-instance 'car 'truck 'van)
  1198. X)
  1199. X
  1200. X
  1201. X
  1202. X(do-test ("the right methods there?" :return-value T)
  1203. X    ((supports-operation-p c :name)            T)
  1204. X    ((supports-operation-p c :set-name)        NIL)
  1205. X    ((supports-operation-p c :set-top-speed)   T)
  1206. X    ((supports-operation-p c :top-speed)       T)
  1207. X    ((supports-operation-p c :turbo-p)         NIL)
  1208. X    ((supports-operation-p c :set-turbo-p)     NIL)
  1209. X    ((supports-operation-p c :not-a-method)    NIL)
  1210. X    ((supports-operation-p c 'describe)        NIL)
  1211. X    ((supports-operation-p c 'init)            NIL)
  1212. X    ((supports-operation-p c 'channelprin)     NIL)
  1213. X    ((supports-operation-p c 'init)            NIL)
  1214. X    ((supports-operation-p c :describe)        T)
  1215. X    ((supports-operation-p c :print)           T)
  1216. X    ((supports-operation-p c :initialize)      T)
  1217. X    ((supports-operation-p c :initialize-variables)  T)
  1218. X    ((supports-operation-p c :init)            T)
  1219. X    ((supports-operation-p c :eql)             T)
  1220. X    ((supports-operation-p c :equal)           T)
  1221. X    ((supports-operation-p c :equalp)          T)
  1222. X    ((supports-operation-p c :typep)           T)
  1223. X    ((supports-operation-p c :copy)            T)
  1224. X    ((supports-operation-p c :copy-state)      T)
  1225. X    ((supports-operation-p c :copy-instance)   T)
  1226. X)
  1227. X
  1228. X
  1229. X(do-test ("typep" :return-value T)
  1230. X    ((typep c 'car)                           T)
  1231. X    ((typep c 'instance)                      T)
  1232. X    ((typep c t)                              T)
  1233. X    ((typep c 'integer)                       NIL)
  1234. X    ((typep '(frog) 'car)                     NIL)
  1235. X    ((type-of c)                              car)
  1236. X)
  1237. X
  1238. X(do-test ("rename-type" :return-value T)
  1239. X    ((rename-type 'car 'auto)                 auto)
  1240. X    ((typep c 'car)                           NIL)
  1241. X    ((typep c 'auto)                          T)
  1242. X    ((type-of c)                              auto)
  1243. X    ((undefine-type 'car)                     NIL)
  1244. X    ((typep c 'auto)                          T)
  1245. X    ((typep c 'auto)                          T)
  1246. X)
  1247. X
  1248. X(do-test ("rename-type error cases" :should-error T)
  1249. X    (rename-type 'float 'pneuname)
  1250. X    (rename-type 'auto 'auto)
  1251. X    (rename-type 'car 'auto)
  1252. X)
  1253. X
  1254. X(do-test ("define-method error case" :should-error T)
  1255. X    (eval '(define-method (car :flat) ()))
  1256. X)
  1257. X
  1258. X(do-test ("now that type car is renamed" :return-value T)
  1259. X    ((=> c :name)                        porsche)
  1260. X    ((=> c :set-top-speed 157)           157)
  1261. X    ((=> c :top-speed)                   157)
  1262. X    ((define-method (auto :sportscar-p) () (> top-speed 130))    (auto :sportscar-p))
  1263. X    ((=> c :sportscar-p)                 T)
  1264. X)
  1265. X
  1266. X
  1267. X(do-test ("define a new type car" :return-value T)
  1268. X    ((define-type car (:var railroad) (:var type) :all-settable)  car)
  1269. X)
  1270. X
  1271. X(do-test ("now that we have a new type car" :return-value T)
  1272. X    ((=> c :name)  porsche) 
  1273. X    ((=> c :set-top-speed 157)  157) 
  1274. X    ((=> c :top-speed)  157)
  1275. X    ((define-method (auto :sportscar-p) () (> top-speed 130))    (auto :sportscar-p))
  1276. X    ((=> c :sportscar-p)                 T)
  1277. X    ((undefine-type 'car)                T)
  1278. X)
  1279. X
  1280. X
  1281. X(do-test ("type for rename-type and undefine-type" :return-value T)
  1282. X    ((define-type other)  other)
  1283. X)
  1284. X
  1285. X(do-test ("rename-type syntax" :should-error T)
  1286. X    (rename-type 'auto NIL)
  1287. X    (rename-type 'other 'auto)
  1288. X    (rename-type NIL 'auto)
  1289. X    (rename-type '(a) 'other)
  1290. X    (rename-type 'other '(a b))
  1291. X    (rename-type)
  1292. X    (rename-type 'auto)
  1293. X)
  1294. X       
  1295. X
  1296. X(do-test ("undefine-type" :return-value T)
  1297. X   ((undefine-type 'auto)                    T)
  1298. X   ((null (type-of c))                        NIL)
  1299. X   ((eq (type-of c) T)                        NIL)
  1300. X   ((member (type-of c) '(auto car))          NIL)
  1301. X   ((symbolp (type-of c))                     T)
  1302. X   ((undefine-type 'auto)                     NIL)
  1303. X   ((undefine-type 'other)                    T)
  1304. X   ((undefine-type 'float)                    NIL)
  1305. X)
  1306. X
  1307. X
  1308. X(do-test ("let's use those undefined types" :should-error T)
  1309. X   (make-instance 'auto)
  1310. X   (eval '(define-method (auto :burp) () T))
  1311. X   (=> c :name)
  1312. X)
  1313. X
  1314. X(do-test ("send? to object with undefined type" :return-value T)
  1315. X
  1316. X   ((send? c :name)  NIL)
  1317. X
  1318. X)
  1319. X
  1320. X
  1321. X(do-test ("undefine-type syntax" :should-error T)
  1322. X   (undefine-type '(a big dog))
  1323. X)
  1324. X
  1325. X(do-test ("define-type syntax" :should-error T)
  1326. X    (eval '(define-type)) 
  1327. X    (eval '(define-type (a list)))
  1328. X    (eval '(define-type actress ann-margret))
  1329. X    (eval '(define-type actress (ann-margret)))
  1330. X    (eval '(define-type actress (:var))) 
  1331. X    (eval '(define-type actress (:var :var))) 
  1332. X    (eval '(define-type actress (:var :a-keyword))) 
  1333. X    (eval '(define-type actress (:var twin) (:var not-twin) (:var twin))) 
  1334. X    (eval '(define-type actress (:var ann-margret ()))) 
  1335. X    (eval '(define-type actress (:var ann-margret dyan-cannon))) 
  1336. X    (eval '(define-type actress (:var ann-margret (:not-option lips))))
  1337. X    (eval '(define-type actress (:var ann-margret (:init))))
  1338. X    (eval '(define-type actress (:var ann-margret (:init 'one 'two))))
  1339. X    (eval '(define-type actress (:var ann-margret :not-an-option)))
  1340. X    (eval '(define-type actress (:var ann-margret (:gettable))))
  1341. X)
  1342. X    
  1343. X(do-test ("various define-types that should work" :return-value T)
  1344. X    ((undefine-type 'actress) NIL)
  1345. X    ((undefine-type 'self) NIL)
  1346. X)
  1347. X
  1348. X(do-test ("define an actress" :return-value T)
  1349. X    ((define-type actress (:var actress))  actress)
  1350. X)
  1351. X    
  1352. X(do-test ("check self" :return-value T)
  1353. X    ((eval '(define-type self (:var me :settable (:init 'hit))))  self)
  1354. X    ((let ((self (make-instance 'self))) (=> self :me))  hit)
  1355. X
  1356. X)
  1357. X
  1358. X(do-test "get rid of self"
  1359. X    (undefine-type 'self)
  1360. X)
  1361. X
  1362. X(do-test ("initial funny business setup" :return-value T)
  1363. X    ((define-type oedipus-rex)    oedipus-rex)
  1364. X    ((define-type laius (:inherit-from oedipus-rex))  laius)
  1365. X    ((define-type jocasta (:inherit-from laius))  jocasta)
  1366. X)
  1367. X
  1368. X(do-test ("check for inheritence funny business" :should-error T)
  1369. X    (eval '(define-type oedipus-rex (:inherit-from oedipus-rex)))
  1370. X    (eval '(define-type oedipus-rex (:inherit-from laius)))
  1371. X    (eval '(define-type oedipus-rex (:inherit-from jocasta)))
  1372. X)
  1373. X
  1374. X(do-test ("clean up after funny business check" :return-value T)    
  1375. X    ((undefine-type 'jocasta) T)
  1376. X    ((undefine-type 'laius) T)
  1377. X    ((undefine-type 'oedipus-rex) T)
  1378. X)
  1379. X     
  1380. X(do-test ("get rid of it" :return-value T)
  1381. X      ((undefine-type 'animal) NIL)
  1382. X)
  1383. X
  1384. X(do-test ("general animal test" :return-value T)
  1385. X    ((list (makunbound 'name)
  1386. X       (makunbound 'num-legs)
  1387. X       (makunbound 'color)
  1388. X       (makunbound 'lives-where))  (name num-legs color lives-where))
  1389. X    ((define-type animal 
  1390. X         (:var name :gettable)
  1391. X             (:var num-legs :gettable)
  1392. X         (:var color (:init 'brown))
  1393. X         (:var lives-where (:init 'on-ground) :settable)
  1394. X         :all-initable
  1395. X         )  animal)
  1396. X    ((instancep (setq an-animal (make-instance 'animal :name 'horse :num-legs 4)))   T)
  1397. X    ((type-of an-animal)                 animal)
  1398. X    ((typep an-animal 'animal)           T)
  1399. X    ((supports-operation-p an-animal :name)               T)
  1400. X    ((supports-operation-p an-animal :set-name)           NIL)
  1401. X    ((supports-operation-p an-animal :num-legs)           T)
  1402. X    ((supports-operation-p an-animal :set-num-legs)       NIL)
  1403. X    ((supports-operation-p an-animal :color)              NIL)
  1404. X    ((supports-operation-p an-animal :set-color)          NIL)
  1405. X    ((supports-operation-p an-animal :lives-where)        T)
  1406. X    ((supports-operation-p an-animal :set-lives-where)    T)
  1407. X    ((=> an-animal :num-legs)            4)
  1408. X    ((=> an-animal :name)                horse)
  1409. X    ((=> an-animal :lives-where)         on-ground)
  1410. X    ((=> an-animal :set-lives-where 'ocean)  ocean)
  1411. X    ((=> an-animal :lives-where)         ocean)
  1412. X)
  1413. X
  1414. X(do-test ("=> error case to animal" :should-error T)
  1415. X    (setq no-animal (make-instance 'animal :rocky 'bullwinkle))
  1416. X    name
  1417. X    (=> an-animal :set-name 'new-name)
  1418. X    name                              
  1419. X    num-legs                          
  1420. X    (=> an-animal :set-num-legs)      
  1421. X    (=> an-animal :set-num-legs 8)    
  1422. X    (=> an-animal :color)             
  1423. X    color                             
  1424. X    (=> an-animal :set-color 'red)    
  1425. X    lives-where                       
  1426. X    (=> an-animal :not-a-method)      
  1427. X    (=> an-animal :set-lives-where)   
  1428. X)
  1429. X
  1430. X
  1431. X(do-test ("=> syntax error check" :should-error T)
  1432. X    (eval '(=>))           
  1433. X    (eval '(=> an-animal)) 
  1434. X    (=> animal :lives-where)
  1435. X    (=> an-animal NIL)      
  1436. X    (=> NIL :lives-where)   
  1437. X    (=> an-animal :lives-where 'extra-parm)
  1438. X)
  1439. X
  1440. X
  1441. X
  1442. X(do-test ("supports-operation-p syntax" :should-error T)
  1443. X    (supports-operation-p animal :lives-where) 
  1444. X)
  1445. X
  1446. X(do-test ("supports-operation-p syntax" :return-value T)
  1447. X    ((supports-operation-p an-animal NIL)            NIL)
  1448. X    ((supports-operation-p NIL :lives-where)         NIL)
  1449. X)        
  1450. X
  1451. X
  1452. X(do-test ("instancep syntax" :return-value T)
  1453. X    ((instancep 'float)                     NIL)
  1454. X    ((instancep an-animal)                  T)
  1455. X)
  1456. X
  1457. X
  1458. X
  1459. X(do-test ("send? to animal"  :return-value T)
  1460. X    ((send? an-animal :name)                horse)
  1461. X    ((send? an-animal :set-name 'new-name)  NIL)
  1462. X    ((send? an-animal :num-legs)            4)
  1463. X    ((send? an-animal :set-num-legs)        NIL)
  1464. X    ((send? an-animal :set-num-legs 8)      NIL)
  1465. X    ((send? an-animal :color)               NIL)
  1466. X    ((send? an-animal :set-color 'red)      NIL)
  1467. X    ((send? an-animal :lives-where)         ocean)
  1468. X    ((send? an-animal :not-a-method)        NIL)
  1469. X    ((send? an-animal :set-lives-where 'mars)  mars)
  1470. X    ((send? an-animal :lives-where)         mars)
  1471. X    ((send? an-animal NIL)            NIL)
  1472. X    ((send? NIL :lives-where)         NIL)
  1473. X)
  1474. X
  1475. X
  1476. X(do-test ("send? syntax and error case" :should-error T)
  1477. X    (send? an-animal :set-lives-where)
  1478. X    (eval '(send?)) 
  1479. X    (eval '(send? an-animal))
  1480. X    (send? animal :lives-where) 
  1481. X    (send? an-animal :lives-where 'extra-parm) 
  1482. X)
  1483. X
  1484. X
  1485. X
  1486. X(do-test ("define-method in general" :return-value T)
  1487. X    ((define-method (animal :num-legs) ()
  1488. X        num-legs)            (animal :num-legs))
  1489. X    ((define-method (animal :num-legs) ()
  1490. X        num-legs)            (animal :num-legs))
  1491. X    ((define-method (animal :set-num-legs) (new-num-legs)
  1492. X        (setq num-legs new-num-legs))
  1493. X                                     (animal :set-num-legs))
  1494. X    ((=> an-animal :num-legs)  4)
  1495. X    ((=> an-animal :num-legs)  4)
  1496. X    ((=> an-animal :set-num-legs 2)  2)
  1497. X    ((=> an-animal :num-legs)  2)
  1498. X    ((define-method (animal :doc) () "doctari" "veterinarian")  (animal :doc))
  1499. X    ((define-method (animal :quote-two) 'train (list quote train))  (animal :quote-two))
  1500. X)
  1501. X
  1502. X
  1503. X(do-test ("define-method syntax" :should-error T)
  1504. X    (eval '(define-method (float :nines) () ))
  1505. X    (=> an-animal :set-num-legs)
  1506. X    (=> an-animal :set-num-legs 1 'and 'a 2)
  1507. X    (eval '(define-method))
  1508. X    (eval '(define-method 'frog))
  1509. X    (eval '(define-method (corn mash)))
  1510. X    (eval '(define-method (animal mash) bleach))
  1511. X)
  1512. X
  1513. X
  1514. X(do-test ("undefine-method" :return-value T)
  1515. X    ((=> (make-instance 'animal) :doc)  "veterinarian")
  1516. X    ((undefine-method 'animal 'not-a-method)  NIL)
  1517. X    ((undefine-method 'animal '(a))  NIL)
  1518. X    ((undefine-method 'animal :quote-two)  T)
  1519. X    ((undefine-method 'animal :quote-two)  NIL)
  1520. X    ((=> an-animal :doc)  "veterinarian")
  1521. X    ((undefine-method 'animal :doc)  T)
  1522. X)
  1523. X
  1524. X(do-test ("undefine-method error cases" :should-error T)
  1525. X    (=> an-animal :doc)
  1526. X    (undefine-method '(a) :quote-two)
  1527. X    (eval '(undefine-method))
  1528. X    (undefine-method 'not-a-type :quote-two)
  1529. X    (undefine-method 'integer :quote-two)
  1530. X)
  1531. X
  1532. X       
  1533. X(do-test ("undefine bird" :return-value T)
  1534. X      ((undefine-type 'bird)                   NIL)
  1535. X)
  1536. X
  1537. X(do-test ("define bird type" :return-value T)
  1538. X    ((define-type bird 
  1539. X         (:inherit-from animal 
  1540. X                :init-keywords 
  1541. X                (:methods :name :num-legs :set-num-legs 
  1542. X                      :lives-where :set-lives-where
  1543. X                      )
  1544. X                )
  1545. X         (:var aquatic-p (:init NIL))
  1546. X         :all-initable
  1547. X         :all-settable
  1548. X         )                           bird)
  1549. X)
  1550. X
  1551. X
  1552. X(do-test ("make bird instances" :return-value T)
  1553. X    ((instancep (setf ibis
  1554. X    (make-instance 'bird :name 'ibis :num-legs 2 :aquatic-p T)))   T)
  1555. X    ((=> ibis :name)                      ibis)
  1556. X    ((=> ibis :num-legs)                  2)
  1557. X    ((=> ibis :aquatic-p)                 T)
  1558. X    ((=> ibis :lives-where)               on-ground)
  1559. X)
  1560. X
  1561. X
  1562. X(do-test ("make-instance error cases" :should-error T)
  1563. X    (make-instance 'bird :num-legs)
  1564. X    (make-instance 'bird :not-init-keyword 89) 
  1565. X    (=> ibis :color)               
  1566. X)
  1567. X
  1568. X
  1569. X(do-test ("undefine horse" :return-value T)
  1570. X    ((undefine-type 'horse)                   NIL)
  1571. X)
  1572. X
  1573. X(do-test ("define horse type" :return-value T)
  1574. X
  1575. X    ((define-type horse
  1576. X         (:inherit-from animal 
  1577. X                :init-keywords 
  1578. X                (:methods :except :num-legs :set-num-legs
  1579. X                      )
  1580. X                )
  1581. X         (:var races-won (:init NIL) :settable)
  1582. X         )                           horse)
  1583. X)
  1584. X
  1585. X
  1586. X(do-test ("make horse instances" :return-value T)
  1587. X    ((instancep (setf wildfire
  1588. X    (make-instance 'horse :name 'wildfire)))   T)
  1589. X    ((=> wildfire :name)                      wildfire)
  1590. X    ((=> wildfire :lives-where)               on-ground)
  1591. X)
  1592. X
  1593. X(do-test ("make horse instance error cases" :should-error T)
  1594. X    (=> wildfire :num-legs) 
  1595. X    (=> wildfire :color)    
  1596. X    (=> wildfire :aquatic-p)
  1597. X    (make-instance 'horse :not-init-keyword 89) 
  1598. X    (make-instance 'horse :name) 
  1599. X)
  1600. X
  1601. X
  1602. X(do-test ("call method on horse" :return-value T)
  1603. X    ((define-method (horse horses-name) () (call-method (animal :name))) 
  1604. X                                              (horse horses-name))
  1605. X    ((=> wildfire 'horses-name)               wildfire)
  1606. X    ((define-method (horse :num-legs) () (call-method (animal :num-legs))) 
  1607. X                                              (horse :num-legs))
  1608. X    ((define-method (horse :set-num-legs) (new-num-legs) (call-method (animal :set-num-legs) new-num-legs))
  1609. X                                              (horse :set-num-legs))
  1610. X    ((=> wildfire :set-num-legs 6)            6)
  1611. X    ((=> wildfire :num-legs)                  6)
  1612. X)
  1613. X
  1614. X
  1615. X(do-test ("apply method on horse" :return-value T)
  1616. X    ((define-method (horse horses-name) () (apply-method (animal :name) ())) 
  1617. X                                          (horse horses-name))
  1618. X    ((=> wildfire 'horses-name)                wildfire)
  1619. X    ((define-method (horse :num-legs) () (apply-method (animal :num-legs) ())) 
  1620. X                                          (horse :num-legs))
  1621. X
  1622. X    ((define-method (horse :set-num-legs) (new-num-legs) (apply-method (animal :set-num-legs) (list new-num-legs)))
  1623. X                                          (horse :set-num-legs))
  1624. X    ((=> wildfire :set-num-legs 6)          6)
  1625. X    ((=> wildfire :num-legs)                     6)
  1626. X)           
  1627. X
  1628. X(do-test ("call-method syntax error cases" :should-error T)
  1629. X    (eval '(call-method (wildfire :name))) 
  1630. X    (eval '(apply-method (horse :name)))   
  1631. X    (eval '(apply-method (horse :name) 'not-a-list)) 
  1632. X    (eval '(define-method (horse horses-name) () (apply-method (horse)) )) 
  1633. X    (eval '(define-method (horse horses-name) () (apply-method (horse :name)) )) 
  1634. X    (eval '(define-method (horse horses-name) () (apply-method (horse :name) 'not-a-list) ))  
  1635. X    (eval '(define-method (horse horses-name) () (apply-method (horse :name 'should-not-be-here)) )) 
  1636. X)
  1637. X
  1638. X(do-test ("undefine-method part II" :return-value T)
  1639. X    ((undefine-method 'horse 'unknown-method)  NIL)
  1640. X    ((undefine-method 'horse 'horses-name)  T)
  1641. X    ((undefine-method 'horse 'horses-name)  NIL)
  1642. X)
  1643. X
  1644. X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1645. X
  1646. X
  1647. END_OF_FILE
  1648. if test 17554 -ne `wc -c <'regress.l'`; then
  1649.     echo shar: \"'regress.l'\" unpacked with wrong size!
  1650. fi
  1651. # end of 'regress.l'
  1652. fi
  1653. echo shar: End of archive 4 \(of 13\).
  1654. cp /dev/null ark4isdone
  1655. MISSING=""
  1656. for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 ; do
  1657.     if test ! -f ark${I}isdone ; then
  1658.     MISSING="${MISSING} ${I}"
  1659.     fi
  1660. done
  1661. if test "${MISSING}" = "" ; then
  1662.     echo You have unpacked all 13 archives.
  1663.     rm -f ark[1-9]isdone ark[1-9][0-9]isdone
  1664. else
  1665.     echo You still need to unpack the following archives:
  1666.     echo "        " ${MISSING}
  1667. fi
  1668. ##  End of shell archive.
  1669. exit 0
  1670. -- 
  1671.  
  1672. Rich $alz            "Anger is an energy"
  1673. Cronus Project, BBN Labs    rsalz@bbn.com
  1674. Moderator, comp.sources.unix    sources@uunet.uu.net
  1675.